home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / vectors.c < prev    next >
C/C++ Source or Header  |  1992-10-06  |  6KB  |  250 lines
  1. /* ******************************************************************** */
  2. /*  vector.c         Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /*  Wild thing                                                          */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: vectors.c,v 1.4 1992/01/09 22:29:12 pab Exp $
  9.  *
  10.  * $Log: vectors.c,v $
  11.  * Revision 1.4  1992/01/09  22:29:12  pab
  12.  * Fixed for low tag ints
  13.  *
  14.  * Revision 1.3  1991/12/22  15:14:46  pab
  15.  * Xmas revision
  16.  *
  17.  * Revision 1.2  1991/09/11  12:07:52  pab
  18.  * 11/9/91 First Alpha release of modified system
  19.  *
  20.  * Revision 1.1  1991/08/12  16:50:13  pab
  21.  * Initial revision
  22.  *
  23.  * Revision 1.3  1991/02/13  18:27:11  kjp
  24.  * Pass.
  25.  *
  26.  */
  27.  
  28. #define KJPDBG(x) 
  29.  
  30. /*
  31.  * Change Log:
  32.  *   Version 1, October 1989
  33.  *   Hacked everything - not robust ( even slightly ) (24/10/89) KJP
  34.  *   Properly + GC protect (hopefully) 
  35.  *
  36.  *   Garbage checked - OK.
  37.  */
  38.  
  39. #include <stdio.h>
  40. #include "funcalls.h"
  41. #include "defs.h"
  42. #include "structs.h"
  43. #include "global.h"
  44. #include "error.h"
  45. #include "bootstrap.h"
  46.  
  47. /* Modulise: allocation */
  48.  
  49. #include "modboot.h"
  50.  
  51. #define VECTORS_ENTRIES 8
  52.  
  53. MODULE     Module_vectors;
  54. LispObject Module_vectors_values[VECTORS_ENTRIES];
  55.  
  56. static LispObject maximum_vector_index;
  57.  
  58. /* End Modulise: allocation*/
  59.  
  60.  
  61. EUFUN_1( Fn_vectorp, obj)
  62. {
  63.   return((typeof(obj) == TYPE_VECTOR?lisptrue:nil));
  64. }
  65. EUFUN_CLOSE
  66.  
  67. EUFUN_2( Fn_make_vector, n, obj)
  68. {
  69.   LispObject vector;
  70.   int i;
  71.  
  72.   while (!is_fixnum(n)) 
  73.     n = CallError(stacktop,
  74.           "Non-integer vector length in 'make-vector'",n,CONTINUABLE);
  75.  
  76.   if (intval(n) < 0)
  77.     CallError(stacktop,
  78.           "Non-positive vector length in 'make-vector'",n,NONCONTINUABLE);
  79.  
  80. /*
  81.   if (intval(n) == 0) return(nil);
  82. */
  83.  
  84.   if (intval(n) > intval(maximum_vector_index))
  85.     CallError(stacktop,
  86.           "Vector length in 'make-vector' too large",n,NONCONTINUABLE);
  87.  
  88.   /* For the moment using object as an initialisation argument */
  89.  
  90.   vector = (LispObject) allocate_vector(stacktop,intval(n));
  91.  
  92.   obj = ARG_1(stackbase);
  93.   for (i = 0; i < intval(n); ++i) vrefupdate(vector,i,obj);
  94.  
  95.   return(vector);
  96. }
  97. EUFUN_CLOSE
  98.  
  99. EUFUN_2( Fn_make_vector_optional, n, args)
  100. {
  101.   return(EUCALL_2(Fn_make_vector,n,(args == nil ? nil : CAR(args))));
  102. }
  103. EUFUN_CLOSE
  104.  
  105. EUFUN_1( Fn_vector_length, vect)
  106. {
  107.   LispObject len;
  108.  
  109.   while (!is_vector(vect))
  110.     vect = CallError(stacktop,
  111.              "Non-vector in 'vector-length'",vect,CONTINUABLE);
  112.  
  113.   len = (LispObject) allocate_integer(stacktop,vect->VECTOR.length);
  114.   
  115.   return(len);
  116. }
  117. EUFUN_CLOSE
  118.  
  119. EUFUN_2( Fn_vector_ref, vect, n)
  120. {
  121.   while (!is_vector(vect))
  122.     vect = CallError(stacktop,
  123.              "Non-vector in 'vector-ref'", vect, CONTINUABLE);
  124.  
  125.   while (!is_fixnum(n))
  126.     vect = CallError(stacktop,
  127.              "Non-integer in 'vector-ref'",
  128.              ARG_1(stackbase), CONTINUABLE );
  129.  
  130.   n = ARG_1(stackbase);
  131.   if (intval(n) < 0 || intval(n) >= vect->VECTOR.length)
  132.     CallError(stacktop,"Index out of range in 'vector-ref'",n,NONCONTINUABLE);
  133.   
  134.   return(vref(vect,intval(n)));
  135. }
  136. EUFUN_CLOSE
  137.  
  138. EUFUN_3( Fn_vector_ref_updator, vect, n, obj)
  139. {
  140.   while (!is_vector(vect))
  141.     vect = CallError(stacktop,
  142.              "Non-vector in 'vector-ref-updator'", vect, CONTINUABLE);
  143.  
  144.   while (!is_fixnum(n))
  145.     vect = CallError(stacktop,
  146.              "Non-integer in 'vector-ref-updator'",
  147.              ARG_1(stackbase), CONTINUABLE );
  148.  
  149.   n = ARG_1(stackbase);
  150.   if (intval(n) < 0 || intval(n) >= vect->VECTOR.length)
  151.     CallError(stacktop,
  152.           "Index out of range in 'vector-ref-updator'",n,NONCONTINUABLE);
  153.  
  154.   vect = ARG_0(stackbase);
  155.   obj = ARG_2(stackbase);
  156.   vrefupdate(vect,intval(n),obj);
  157.  
  158.   return(obj);
  159. }
  160. EUFUN_CLOSE
  161.  
  162. EUFUN_1( Fn_vector, forms)
  163. {
  164.   LispObject vect;
  165.   int i, vlen;
  166.  
  167. /*
  168.   if (forms == nil)
  169.     CallError("Can't make zero length vector in 'vector'",nil,NONCONTINUABLE);
  170. */
  171.  
  172.   EUCALLSET_1(vect, Fn_length, forms);
  173.   vlen = intval(vect);
  174.   vect = (LispObject) allocate_vector(stacktop,vlen);
  175.  
  176.   forms = ARG_0(stackbase);
  177.   for (i = 0; i < vlen; ++i) {
  178.     vrefupdate(vect,i,CAR(forms));
  179.     forms = CDR( forms );
  180.   }
  181.  
  182.   return(vect);
  183. }
  184. EUFUN_CLOSE
  185.  
  186. /* This should just be a method to 'convert' when it exists */
  187.  
  188. EUFUN_1( Fn_convert_vector_list, vect )
  189. {
  190.   LispObject newlist;
  191.   int i;
  192.  
  193.   while (!is_vector(vect)) {
  194.     vect = CallError(stacktop,
  195.              "Non-vector in vector coercion", vect, CONTINUABLE );
  196.   }
  197.  
  198.   newlist = nil;
  199.   for ( i = vect->VECTOR.length; i > 0; --i ) {
  200.     ARG_0(stackbase) = vect;
  201.     EUCALLSET_2(newlist, Fn_cons, vref( vect, i-1 ), newlist );
  202.     vect = ARG_0(stackbase);
  203.   }
  204.  
  205.   return( newlist );
  206. }
  207. EUFUN_CLOSE
  208.  
  209. /* Generic prin... */
  210.  
  211. EUFUN_2( Md_generic_prin_Vector, vect, str)
  212. {
  213.   if (!is_stream(str))
  214.     CallError(stacktop,"generic-prin: non-stream argument",str,NONCONTINUABLE);
  215.  
  216.   fprintf(str->STREAM.handle,"#V(something)");
  217.  
  218.   return(vect);
  219. }
  220. EUFUN_CLOSE
  221.  
  222. void initialise_vectors(LispObject* stacktop)
  223. {
  224.   LispObject getter, setter;
  225.  
  226.   /* Modulise: initialisation */
  227.  
  228.   open_module(stacktop,
  229.           &Module_vectors,Module_vectors_values,"vectors",VECTORS_ENTRIES);
  230.  
  231.   (void) make_module_function(stacktop,"vectorp",Fn_vectorp,1);
  232.   (void) make_module_function(stacktop,
  233.                   "make-vector",Fn_make_vector_optional,-2);
  234.   (void) make_module_function(stacktop,"vector-length",Fn_vector_length,1);
  235.   getter = make_module_function(stacktop,"vector-ref",Fn_vector_ref,2);
  236.   STACK_TMP(getter);
  237.   setter = make_module_function(stacktop,
  238.                 "vector-ref-updator",Fn_vector_ref_updator,3);
  239.   UNSTACK_TMP(getter);
  240.   set_anon_associate(stacktop,getter,setter);
  241.   (void) make_module_function(stacktop,"make-initialized-vector",Fn_vector,-1);
  242.   (void) make_module_function(stacktop,
  243.                   "convert-vector-list",Fn_convert_vector_list,1);
  244.   maximum_vector_index = allocate_integer(stacktop,0xfffff);
  245.   add_root(&maximum_vector_index);
  246.  
  247.   (void) make_module_entry(stacktop,"*maximum-vector-index*",maximum_vector_index);
  248.   close_module();
  249. }
  250.